home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / e_to_l / fbuilder / delphi / demos / extfunc.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  12KB  |  355 lines
  1. { FormulaBuilder                }
  2. { YGB Software, Inc.            }
  3. { Copyright 1995 Clayton Collie }
  4. { All rights reserved           }
  5.  
  6.  
  7. {*
  8.  * External Function Module for
  9.  * FormulaBuilder 1.00 Main Demo
  10.  * Copyright 1995 Clayton Collie
  11.  * All Rights Reserved
  12. *}
  13. {$F+,V-}
  14. unit extfunc;
  15. interface
  16.  
  17. Procedure RegisterFunctions;
  18. Procedure UnregisterFunctions;
  19.  
  20. implementation
  21. uses sysutils,controls,forms,messages,
  22.      dialogs,
  23.      Fbcalc,
  24.      winprocs,wintypes;
  25.  
  26. const
  27.   installed : boolean = false;
  28.   constinstalled : boolean = false;
  29.  
  30. var
  31.   fnCopy, fnRename, fnExec,
  32.   fnExecWait, fnDelete,
  33.   fnErrorMsg, fnMsgBox,
  34.   fnBeep, fnYesNo,
  35.   fnYesNoCancel, fnInputstring : integer;
  36.  
  37.  
  38.  
  39. (* Thanks to stidolph@magnet.com (David Stidolph) for the following *)
  40.  
  41. function FileCopy(source,dest: String): Boolean;
  42. var
  43.   fSrc,fDst,len: Integer;
  44.   size: Longint;
  45.   buffer: packed array [0..2047] of Byte;
  46. begin
  47.   Result := False; { Assume that it WONT work }
  48.   if source <> dest then begin
  49.     fSrc := FileOpen(source,fmOpenRead);
  50.     if fSrc >= 0 then begin
  51.       size := FileSeek(fSrc,0,2);
  52.       FileSeek(fSrc,0,0);
  53.       fDst := FileCreate(dest);
  54.       if fDst >= 0 then begin
  55.         while size > 0 do begin
  56.           len := FileRead(fSrc,buffer,sizeof(buffer));
  57.           FileWrite(fDst,buffer,len);
  58.           size := size - len;
  59.         end;
  60.         FileSetDate(fDst,FileGetDate(fSrc));
  61.         FileClose(fDst);
  62.         FileSetAttr(dest,FileGetAttr(source));
  63.         Result := True;
  64.       end;
  65.       FileClose(fSrc);
  66.     end;
  67.   end;
  68. end;
  69.  
  70.  
  71. {----------------------------------------------------
  72.        Name: WinExecAndWait function
  73. Declaration: WinExecAndWait(Path : Pchar; Visibility : word) : word;
  74.        Unit: UtilBox
  75.        Code: S
  76.        Date: 02/05/95
  77. Description: Execute a Windows or DOS program and wait until it
  78.              returns. In the meantime, continue to process
  79.              Window messages. ( Thanks to Lar Mader. )
  80. -----------------------------------------------------}
  81.  
  82. function WinExecAndWait(Path : Pchar; Visibility : word) : word;
  83. var
  84.   InstanceID : THandle;
  85.   Msg : TMSg;
  86. begin
  87.   InstanceID := WinExec(Path,Visibility);
  88.   if InstanceID < 32 then { a value less than 32 indicates an Exec error }
  89.      WinExecAndWait := InstanceID
  90.   else
  91.     repeat
  92.       while PeekMessage(Msg,0,0,0,PM_REMOVE) do begin
  93.         if Msg.Message = WM_QUIT then
  94.            halt(Msg.wParam);
  95.         TranslateMessage(Msg);
  96.         DispatchMessage(Msg);
  97.       end;
  98.     until GetModuleUsage(InstanceID) = 0;
  99. end;
  100.  
  101.  
  102.   Procedure CopyFileProc(paramcount        : byte;
  103.                          Const params      : TActParamList;
  104.                          var   RetValue    : TValueRec;
  105.                          var   nErrorCode  : integer;
  106.                                exprData    : longint); export;
  107.   begin
  108.     retvalue.vBoolean := FileCopy(params[0].vpString^,params[1].vpString^);
  109.   end;
  110.  
  111.  
  112.   Procedure RenFileProc(bParamcount       : byte;
  113.                         Const params      : TActParamList;
  114.                         var   RetValue    : TValueRec;
  115.                         var   nErrorCode  : integer;
  116.                               exprdata    : longint); export;
  117.   begin
  118.     retvalue.vBoolean := RenameFile(params[0].vpString^,params[1].vpString^);
  119.   end;
  120.  
  121.  
  122.   Procedure RunFileProc(bParamcount       : byte;
  123.                         Const params      : TActParamList;
  124.                         var   RetValue    : TValueRec;
  125.                         var   nErrorCode  : integer;
  126.                               exprdata    : longint); export;
  127.   var visibility : word;
  128.       s          : string[90];
  129.   begin
  130.     if (bParamcount = 1) then
  131.        visibility := SW_MAXIMIZE
  132.     else
  133.        if params[0].vInteger < 0 then
  134.           nErrorCode := EXPR_DOMAIN_ERROR
  135.        else
  136.          begin
  137.             visibility := params[0].vInteger;
  138.             s := params[0].vpString^ + #0;
  139.             retvalue.vInteger := WinExec(@s[1],visibility);
  140.          end;
  141.   end;
  142.  
  143.  
  144.  
  145.   Procedure ExecWaitProc(bParamcount       : byte;
  146.                          Const params      : TActParamList;
  147.                          var   RetValue    : TValueRec;
  148.                          var   nErrorCode  : integer;
  149.                                exprdata    : longint); export;
  150.   var visibility : word;
  151.       s          : string[90];
  152.   begin
  153.     if (bParamcount = 1) then
  154.        visibility := SW_MAXIMIZE
  155.     else
  156.        if params[0].vInteger < 0 then
  157.           nErrorCode := EXPR_DOMAIN_ERROR
  158.        else
  159.          begin
  160.             visibility := params[0].vInteger;
  161.             s := params[0].vpString^ + #0;
  162.             retvalue.vInteger := WinExecAndWait(@s[1],visibility);
  163.          end;
  164.   end;
  165.  
  166.  
  167.   {* Delete a file *}
  168.   Procedure DeleteFileProc(bParamcount       : byte;
  169.                            Const params      : TActParamList;
  170.                            var   RetValue    : TValueRec;
  171.                            var   nErrorCode  : integer;
  172.                                  exprdata    : longint); export;
  173.   begin
  174.     retvalue.vBoolean := DeleteFile(params[0].vpString^);
  175.   end;
  176.  
  177.  
  178.   {* Show an error message dialog box *}
  179.   Procedure DispErrorProc(paramcount        : byte;
  180.                           const params      : TActParamList;
  181.                           var   retvalue    : TValueRec;
  182.                           var   nErrorCode  : integer;
  183.                                 exprdata    : longint); export;
  184.   begin
  185.     MessageDlg(params[0].vpString^,mtError, [mbOk], 0);
  186.   end;
  187.  
  188.  
  189.   Procedure MessageBoxProc(paramcount        : byte;
  190.                            const params      : TActParamList;
  191.                            var   retvalue    : TValueRec;
  192.                            var   nErrorCode  : integer;
  193.                                  exprdata    : longint); export;
  194.   begin
  195.     MessageDlg(params[0].vpString^,mtInformation, [mbOk], 0);
  196.   end;
  197.  
  198.  
  199.   Procedure BeepProc(paramcount        : byte;
  200.                      const params      : TActParamList;
  201.                      var   RetValue    : TValueRec;
  202.                      var   nErrorCode  : integer;
  203.                            exprdata    : longint);
  204.   begin
  205.     if paramcount = 0 then
  206.        MessageBeep(mb_iconhand)
  207.     else
  208.        MessageBeep(params[0].vInteger);
  209.   end;
  210.  
  211.  
  212.   procedure YesNoProc(paramcount        : byte;
  213.                       const Params      : TActParamlist;
  214.                       var   Retvalue    : TValueRec;
  215.                       var   iErrcode    : integer;
  216.                             exprdata    : longint); export;
  217.   begin
  218.     Retvalue.vBoolean :=  MessageDlg(params[0].vpString^,
  219.                                      mtConfirmation,
  220.                                      [mbYes, mbNo], 0) = mrYes;
  221.   end;
  222.  
  223.  
  224.   procedure YesNoCancelProc(paramcount        : byte;
  225.                             const Params      : TActParamlist;
  226.                             var   Retvalue    : TValueRec;
  227.                             var   iErrcode    : integer;
  228.                                   exprdata    : longint); export;
  229.   var tmp : integer;
  230.   begin
  231.    case MessageDlg(params[0].vpString^,mtConfirmation,[mbYes,mbNo,mbCancel],0)of
  232.       mrYes    : retvalue.vInteger := 1;
  233.       mrNo     : retvalue.vInteger := 2;
  234.       mrCancel : retvalue.vInteger := 3;
  235.    end;
  236.   end;
  237.  
  238.  
  239.   procedure InputStringProc(paramcount        : byte;
  240.                             const Params      : TActParamlist;
  241.                             var   Retvalue    : TValueRec;
  242.                             var   iErrcode    : integer;
  243.                                   exprdata    : longint); export;
  244.   var tmpstr : string;
  245.   begin
  246.     tmpstr := params[2].vpString^;
  247.     if InputQuery( Params[0].vpString^, params[1].vpString^, tmpstr ) then
  248.     begin
  249.       tmpstr := tmpstr + #0;
  250.       retvalue.vpString := FBCreateString(@tmpstr[1]);
  251.     end;
  252.   end;
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259. {* Install some standard Windows.h constants *}
  260. Procedure RegisterConstants;
  261. begin
  262.   if constInstalled then exit;
  263.   FBAddNumericConstant('SW_HIDE',SW_HI